Shareware Grab Bag/Shareware Grab Bag.iso/050/calculat.pas

Pascal/Delphi Source File | 1985-06-03 | 14.1 KB | 581 lines

  { TURN ON RECURSION ABILITY, MUST BE FIRST LINE IN PASCAL/MT+    }
  { TURN ON RUN-TIME ERROR CHECKING                }

PROGRAM HANDCALC ;

{   THIS PROGRAM IS INTENDED TO ACT AS A SCIENTIFIC CALCULATOR, WITH    }
{   EXPONENTIATION AND TRANCENDENTAL FUNCTIONS.                }

CONST
    FUNC_LEN  = 6;    { NO. OF CHARACTERS ALLOWED IN A FUNCTION NAME    }
    NUM_FUNCS = 20;    { NO. OF FUNCTIONS RECOGNIZED            }
    PI        = 3.1415926535897323846264338; { THIS IS SILLY OF COURSE }
                        { BUT THE NUMBERS ARE CORRECT }

TYPE
    FUNCTIONS = (ARCTANGENT, COSINE, LOGRITHM, SINE, SQUARE, SQUARE_ROOT,
            EXPONENT, TANGENT, COTANGENT, SECANT, COSECANT,
            ARCSINE, ARCCOSINE, ARCCOTANGENT, ARCSECANT,
            ARCCOSECANT, PIE, RADIANS, LOG, FACTORIAL,
            NON_FUNCTION);

    SET_OF_FUNCS = SET OF FUNCTIONS;
    FUNC_NAME = ARRAY [1..FUNC_LEN] OF CHAR;
    FUNC_REC  = RECORD
            NAME    : FUNC_NAME;
            FUNC_TYPE : FUNCTIONS
            END;
    FUNC_LIST = ARRAY [1..NUM_FUNCS] OF FUNC_REC;

VAR
    ANSWER        : REAL;
    BUF        : STRING[80];
    Z        : INTEGER;    { INDEX INTO BUF }
    F_NAMES        : FUNC_LIST;
    NON_PARM_FUNCS    : SET_OF_FUNCS;
    DEBUG_MODE    : BOOLEAN;

PROCEDURE SCREENCLR;

    VAR
        I : INTEGER;

    BEGIN { SCREENCLR }
    { IF YOUR TERMINAL CAN CLEAR THE SCREEN (WITH SAY A CONTROL-Z) THEN }
    { OUTPUT WHAT EVER CHARACTERS ARE NEEDED IN PLACE OF THIS LOOP      }

    FOR I := 1 TO 24 DO
        WRITELN

    END;  { SCREENCLR }
FUNCTION SKIP_LINE (N : INTEGER) : CHAR;

    VAR
    I : INTEGER;

    BEGIN { SKIP_LINE }
    FOR I := 1 TO N DO
    WRITELN;
    SKIP_LINE := CHR(0)
    END;  { SKIP_LINE }
PROCEDURE INITIALIZATION;

     VAR
    I : INTEGER;

     PROCEDURE INIT_FUNCS;

    BEGIN { INIT_FUNCS }
        { THE ORDER OF THE STRINGS IN F_NAMES MUST BE ALPHABETICAL }
        { THIS SHOULD BE REMEMBERED WHEN ADDING NEW FUNCTIONS       }
    F_NAMES[1].NAME := 'ARCCOS';    F_NAMES[1].FUNC_TYPE := ARCCOSINE;
    F_NAMES[2].NAME := 'ARCCOT';    F_NAMES[2].FUNC_TYPE := ARCCOTANGENT;
    F_NAMES[3].NAME := 'ARCCSC';    F_NAMES[3].FUNC_TYPE := ARCCOSECANT;
    F_NAMES[4].NAME := 'ARCSEC';    F_NAMES[4].FUNC_TYPE := ARCSECANT;
    F_NAMES[5].NAME := 'ARCSIN';    F_NAMES[5].FUNC_TYPE := ARCSINE;
    F_NAMES[6].NAME := 'ARCTAN';    F_NAMES[6].FUNC_TYPE := ARCTANGENT;
    F_NAMES[7].NAME := 'COS   ';    F_NAMES[7].FUNC_TYPE := COSINE;
    F_NAMES[8].NAME := 'COT   ';    F_NAMES[8].FUNC_TYPE := COTANGENT;
    F_NAMES[9].NAME := 'CSC   ';    F_NAMES[9].FUNC_TYPE := COSECANT;
    F_NAMES[10].NAME:= 'EXP   ';    F_NAMES[10].FUNC_TYPE:= EXPONENT;
    F_NAMES[11].NAME:= 'FACTOR';    F_NAMES[11].FUNC_TYPE:= FACTORIAL;
    F_NAMES[12].NAME:= 'LN    ';    F_NAMES[12].FUNC_TYPE:= LOGRITHM;
    F_NAMES[13].NAME:= 'LOG   ';    F_NAMES[13].FUNC_TYPE:= LOG;
    F_NAMES[14].NAME:= 'PI    ';    F_NAMES[14].FUNC_TYPE:= PIE;
    F_NAMES[15].NAME:= 'RADIAN';    F_NAMES[15].FUNC_TYPE:= RADIANS;
    F_NAMES[16].NAME:= 'SEC   ';    F_NAMES[16].FUNC_TYPE:= SECANT;
    F_NAMES[17].NAME:= 'SIN   ';    F_NAMES[17].FUNC_TYPE:= SINE;
    F_NAMES[18].NAME:= 'SQR   ';    F_NAMES[18].FUNC_TYPE:= SQUARE;
    F_NAMES[19].NAME:= 'SQRT  ';    F_NAMES[19].FUNC_TYPE:= SQUARE_ROOT;
    F_NAMES[20].NAME:= 'TAN   ';    F_NAMES[20].FUNC_TYPE:= TANGENT;
    NON_PARM_FUNCS := [PIE]
    END;  { INIT_FUNCS }

     BEGIN { INITIALIZATION }
        { CLEAR THE SCREEN }
     SCREENCLR;
     WRITELN ('CALCULATOR');
     WRITELN;
     WRITELN ('BY WARREN A. SMITH  --  JULY 29, 1981');
     WRITE (SKIP_LINE(4));
     WRITELN ('A ''?'' AT THE BEGINNING OF A LINE WILL BRING UP A LISTING');
     WRITELN ('  OF POSSIBLE FUNCTIONS AND OPERATORS THAT MAY BE USED.');
     WRITELN;
     WRITELN ('A DOLLAR SIGN ''$'' AT THE BEGINNING OF A LINE WILL');
     WRITELN ('  CAUSE THIS PROGRAM TO TERMINATE.');
     WRITELN;
     DEBUG_MODE := FALSE;
     INIT_FUNCS
     END;  { INITIALIZATION }



FUNCTION TAB (N : INTEGER) : CHAR;

    VAR
    I : INTEGER;

    BEGIN { TAB }
    FOR I := 1 TO N DO
    WRITE (' ')
    END;  { TAB }

FUNCTION UPPER (IN_CHAR : CHAR) : CHAR;

     BEGIN { UPPER }
     IF (IN_CHAR >= 'a') AND (IN_CHAR <= 'z') THEN
         UPPER := CHR(ORD(IN_CHAR) + (ORD('A') - ORD('a')))
     ELSE
         UPPER := IN_CHAR
     END;  { UPPER }

PROCEDURE HELP;

    VAR
    RESPONSE : CHAR;

    BEGIN { HELP }
     SCREENCLR;
     WRITELN ('  THE CURRENTLY AVAILABLE FUNCTIONS ARE :');
     WRITELN;
     WRITELN ('    ARCCOSINE   - ARCCOS    ARCCOTANGENT     - ARCCOT');
     WRITELN ('    ARCCOSECANT - ARCCSC    ARCSECANT        - ARCSEC');
     WRITELN ('    ARCSINE     - ARCSIN    ARCTANGENT       - ARCTAN');
     WRITELN ('    COSINE      - COS       COTANGENT        - COT   ');
     WRITELN ('    COSECANT    - CSC       NATURAL EXPONENT - EXP   ');
     WRITELN ('    NATURAL LOG - LN        SECANT           - SEC   ');
     WRITELN ('    SINE        - SIN       SQUARE           - SQR   ');
     WRITELN ('    SQUARE ROOT - SQRT      TANGENT          - TAN   ');
     WRITELN ('    LOG BASE 10 - LOG       FACTORIAL        - FACTOR');
     WRITELN ('    VALUE OF PI - PI                    ');
     WRITELN;
     WRITELN ('  ALLOWABLE OPERATORS ARE:');
     WRITELN ('      ''+'', ''-'', ''*'', ''/'', AND ''^'' (EXPONENTIATION)');
     WRITELN;
     WRITELN ('  UPPER CASE AND LOWER CASE ARE IRRELEVANT IN FUNCTION NAMES');
     WRITELN ('  A ''$'' WILL END THE PROGRAM, A ''!'' TURNS ON DEBUG MODE ');
     WRITELN;
     WRITELN ('HIT THE CARRIAGE RETURN TO PROCEED.');
     READ (RESPONSE);
    END;  { HELP }

FUNCTION EOLN : BOOLEAN;

    BEGIN { EOLN }
    EOLN := Z > LENGTH(BUF)
    END;  { EOLN }

PROCEDURE SLOUGH_BLANKS;

    BEGIN { SLOUGH_BLANKS }
    WHILE (BUF[Z] = ' ') AND (NOT EOLN) DO
       Z := Z + 1
    END;  { SLOUGH_BLANKS }

PROCEDURE GET_EXPR;

    BEGIN { GET_EXPR }
    REPEAT
    WRITELN;
    WRITELN ('TYPE IN AN EXPRESSION TO BE SOLVED.');
    READLN (BUF);
    Z := 1;
    SLOUGH_BLANKS
    UNTIL NOT EOLN
    END;  { GET_EXPR }

FUNCTION EXPR : REAL;

     VAR
    UNARY,
    ANSWER    : REAL;

     FUNCTION TERM : REAL;

    VAR
        ANSWER    : REAL;

    FUNCTION EXPON : REAL;

        VAR
        ANSWER : REAL;

        FUNCTION XTOY (X, Y : REAL) : REAL;

        BEGIN { XTOY }
        IF X >= 0.0 THEN
            XTOY := EXP(Y * LN(X))
        ELSE
            XTOY := 0.0
        END;  { XTOY }

        FUNCTION FACTOR : REAL;

           VAR
            ANSWER,
            X    : REAL;
            FUNC    : FUNCTIONS;
        FUNCTION DIGIT (IN_CHAR : CHAR) : BOOLEAN ;

             BEGIN { DIGIT }
             DIGIT := IN_CHAR IN ['0','1','2','3','4','5','6','7',
                      '8','9']
             END;  { DIGIT }
        PROCEDURE READ (VAR ANSWER : REAL);

             VAR
            FACT_POWER : REAL;

             BEGIN { READ }
             ANSWER := 0.0;
             SLOUGH_BLANKS;
             WHILE DIGIT (BUF[Z]) AND NOT EOLN DO
            BEGIN
            ANSWER := ANSWER * 10.0 + (ORD(BUF[Z])-ORD('0'));
            Z := Z + 1
            END;
             IF (BUF[Z] = '.') AND NOT EOLN THEN
            BEGIN
            Z := Z + 1;
            FACT_POWER := 1.0;
            WHILE DIGIT (BUF[Z]) AND NOT EOLN DO
                BEGIN
                FACT_POWER := FACT_POWER / 10.0;
                ANSWER := ANSWER+(ORD(BUF[Z])-ORD('0'))*FACT_POWER;
                Z := Z + 1
                END
            END
             END;  { READ }



        FUNCTION LETTER (VAR IN_CHAR : CHAR) : BOOLEAN;

             BEGIN { LETTER }
             IN_CHAR := UPPER (IN_CHAR);
             LETTER := IN_CHAR IN ['A','B','C','D','E','F','G','H',
                       'I','J','K','L','M','N','O','P',
                       'Q','R','S','T','U','V','W','X',
                       'Y','Z']
             END;  { LETTER }

        FUNCTION GET_FUNC_TYPE : FUNCTIONS;

             VAR
            ID : FUNC_NAME;
            INDEX : INTEGER;

             FUNCTION SEARCH_FUNCS (ID : FUNC_NAME) : FUNCTIONS;

              VAR
                I, J, K    : INTEGER;

              BEGIN { SEARCH_FUNCS }
              I := 1;
               J := NUM_FUNCS;
              REPEAT
                   K := (I+J) DIV 2;      { BINARY SEARCH }
                   WITH F_NAMES[K] DO
                   BEGIN
                   IF NAME <= ID  THEN
                    I := K+1;

                   IF NAME >= ID THEN
                    J := K-1
                   END

              UNTIL I > J;
               IF F_NAMES[K].NAME <> ID THEN
                   SEARCH_FUNCS := NON_FUNCTION
              ELSE
                   SEARCH_FUNCS := F_NAMES[K].FUNC_TYPE
              END;  { SEARCH_FUNCS }

             BEGIN { GET_FUNC_TYPE }
             INDEX := 1;
             REPEAT
              ID [INDEX] := BUF[Z];
              Z := Z + 1;
              INDEX := INDEX + 1
             UNTIL NOT LETTER(BUF[Z]) OR EOLN OR (INDEX > FUNC_LEN);
             WHILE INDEX <= FUNC_LEN DO
              BEGIN
              ID [INDEX] := ' ';
              INDEX := INDEX + 1
              END;

             GET_FUNC_TYPE := SEARCH_FUNCS (ID)
             END;  { GET_FUNC_TYPE }

        FUNCTION TAN (X : REAL) : REAL;

            BEGIN { TAN }
            TAN := SIN(X) / COS(X)
            END;  { TAN }

        FUNCTION COT (X : REAL) : REAL;

            BEGIN { COT }
            COT := COS(X) / SIN(X)
            END;  { COT }

        FUNCTION SEC (X : REAL) : REAL;

            BEGIN { SEC }
            SEC := 1.0 / COS(X)
            END;  { SEC }

        FUNCTION CSC (X : REAL) : REAL;

            BEGIN { CSC }
            CSC := 1.0 / SIN(X)
            END;  { CSC }

        FUNCTION ARCSIN (X : REAL) : REAL;

            BEGIN { ARCSIN }
            ARCSIN := ARCTAN(X / SQRT(1.0 - SQR(X)))
            END;  { ARCSIN }

        FUNCTION ARCCOS (X : REAL) : REAL;

            BEGIN { ARCCOS }
            ARCCOS := PI / 2.0 - ARCTAN (X / SQRT(1.0 - SQR(X)))
            END;  { ARCCOS }

        FUNCTION ARCCOT (X : REAL) : REAL;

            BEGIN { ARCCOT }
            ARCCOT := PI / 2.0 - ARCTAN (X)
            END;  { ARCCOT }

        FUNCTION ARCSEC (X : REAL) : REAL;

            BEGIN { ARCSEC }
            ARCSEC := ARCTAN (SQRT(SQR(X) - 1.0))
            END;  { ARCSEC }

        FUNCTION ARCCSC (X : REAL) : REAL;

            BEGIN { ARCCSC }
            ARCCSC := ARCTAN (1.0 / SQRT(SQR(X) - 1.0))
            END;  { ARCCSC }

        FUNCTION RADIAN (X : REAL) : REAL;

            BEGIN { RADIAN }
            RADIAN := X * (PI / 180.0)
            END;  { RADIAN }

        FUNCTION LOG10 (X : REAL) : REAL;

            BEGIN { LOG10 }
            LOG10 := LN(X) / LN(10.0)
            END;  { LOG10 }

        FUNCTION FACTORL (X : REAL) : REAL;

            VAR
            INT_X, I    : INTEGER;
            PRODUCT        : REAL;

            BEGIN { FACTORL }
            INT_X := ROUND(X);
            IF INT_X = 0 THEN
            FACTORL := 1.0
            ELSE
            BEGIN
            PRODUCT := 1.0;
            FOR I := 2 TO INT_X DO
                PRODUCT := PRODUCT * I;
            FACTORL := PRODUCT
            END
            END;  { FACTORL }

        BEGIN { FACTOR }
        SLOUGH_BLANKS;
        IF DIGIT (BUF[Z]) OR (BUF[Z] = '.') THEN
             READ (ANSWER)
        ELSE
             IF BUF[Z] = '(' THEN
              BEGIN
              Z := Z + 1;
              ANSWER := EXPR;
              IF BUF[Z] <> ')' THEN
                BEGIN
                WRITE (TAB(Z-1),'^ ');
                WRITELN ('*** '')'' EXPECTED')
                END
              ELSE
                Z := Z + 1
              END
             ELSE
              IF LETTER (BUF[Z]) THEN
                BEGIN
                FUNC := GET_FUNC_TYPE;
                SLOUGH_BLANKS;
                IF NOT (FUNC IN NON_PARM_FUNCS) THEN
                    BEGIN
                    IF BUF[Z] = '(' THEN
                    BEGIN
                    Z := Z + 1;
                    ANSWER := EXPR
                    END
                    ELSE
                    BEGIN
                    WRITE (TAB(Z-1), '^ ');
                    WRITE ('*** ''('' EXPECTED, ANSWER ');
                    WRITELN ('MAY BE IN ERROR')
                    END;
                    SLOUGH_BLANKS;
                    IF BUF[Z] = ')' THEN
                    Z := Z + 1
                    ELSE
                    BEGIN
                    WRITE (TAB(Z-1), '^ ');
                    WRITE ('*** '')'' EXPECTED, ANSWER ');
                    WRITELN ('MAY BE IN ERROR')
                    END
                    END;
                CASE FUNC OF
                    LOGRITHM    : ANSWER := LN (ANSWER);
                    EXPONENT    : ANSWER := EXP (ANSWER);
                    LOG        : ANSWER := LOG10 (ANSWER);
                    SQUARE      : ANSWER := SQR (ANSWER);
                    SQUARE_ROOT : ANSWER := SQRT (ANSWER);
                    FACTORIAL    : ANSWER := FACTORL (ANSWER);
                    COSINE    : ANSWER :=
                            COS (RADIAN(ANSWER));
                    SINE    : ANSWER :=
                            SIN (RADIAN(ANSWER));
                    ARCTANGENT  : ANSWER :=
                               ARCTAN (RADIAN(ANSWER));
                    TANGENT    : ANSWER :=
                             TAN (RADIAN(ANSWER));
                    COTANGENT   : ANSWER :=
                             COT (RADIAN(ANSWER));
                    SECANT    : ANSWER :=
                             SEC (RADIAN(ANSWER));
                    COSECANT    : ANSWER :=
                             COS (RADIAN(ANSWER));
                    ARCSINE    : ANSWER :=
                               ARCSIN (RADIAN(ANSWER));
                    ARCCOSINE   : ANSWER :=
                               ARCCOS (RADIAN(ANSWER));
                    ARCCOTANGENT: ANSWER :=
                               ARCCOT (RADIAN(ANSWER));
                    ARCSECANT   : ANSWER :=
                               ARCSEC (RADIAN(ANSWER));
                    ARCCOSECANT : ANSWER :=
                            ARCCSC (ANSWER);
                    PIE        : ANSWER := PI;
                    RADIANS    : ANSWER := RADIAN (ANSWER);
                    NON_FUNCTION: BEGIN
                          WRITE (TAB(Z-1), '^ ');
                          WRITELN
                        ('*** UNINOWN FUNCTION NAME')
                          END
                    END; { CASE }
                SLOUGH_BLANKS
                END
              ELSE
                BEGIN
                WRITE (TAB(Z-1), '^ ');
                WRITE ('*** UNKNOWN SYNTAX, ANSWER MAY ');
                WRITELN ('BE IN ERROR')
                END;
        IF DEBUG_MODE THEN
            WRITELN ('RESULT FROM FACTOR = ', ANSWER:20:8);
        FACTOR := ANSWER
        END;  { FACTOR }

        BEGIN { EXPON }
        ANSWER := FACTOR;
        SLOUGH_BLANKS;
        WHILE BUF[Z] = '^' DO
        BEGIN
        Z := Z + 1;
        ANSWER := XTOY (ANSWER, FACTOR);
        SLOUGH_BLANKS
        END;
        IF DEBUG_MODE THEN
        WRITELN ('RESULT FROM EXPON = ', ANSWER:20:8);
        EXPON := ANSWER
        END;  { EXPON }

      BEGIN { TERM }
      ANSWER := EXPON;
      SLOUGH_BLANKS;
      WHILE BUF[Z] IN ['*', '/'] DO
        BEGIN
        IF BUF[Z] = '*' THEN
             BEGIN
             Z := Z + 1;
             ANSWER := ANSWER * EXPON
             END
        ELSE
             BEGIN
             Z := Z + 1;
             ANSWER := ANSWER / EXPON;
             END;
        SLOUGH_BLANKS
        END;
      IF DEBUG_MODE THEN
        WRITELN ('RESULT FROM TERM = ', ANSWER:20:8);
      TERM := ANSWER
      END;  { TERM }

     BEGIN { EXPR }
     SLOUGH_BLANKS;
     UNARY := 1.0;
     IF BUF[Z] IN ['+','-'] THEN
    BEGIN
    IF BUF[Z] = '-' THEN
        UNARY := -1.0;
    Z := Z + 1
    END;
     ANSWER := UNARY * TERM;
     SLOUGH_BLANKS;
     WHILE BUF[Z] IN ['+', '-'] DO
    BEGIN
    IF BUF[Z] = '+' THEN
        BEGIN
        Z := Z + 1;
        ANSWER := ANSWER + TERM
        END
    ELSE
        BEGIN
        Z := Z + 1;
        ANSWER := ANSWER - TERM
        END;
    SLOUGH_BLANKS
    END;
     IF DEBUG_MODE THEN
    WRITELN ('RESULT FROM EXPR =', ANSWER:20:8);
     EXPR := ANSWER
     END;  { EXPR }

BEGIN { MAIN }
INITIALIZATION;
GET_EXPR;
WHILE BUF[Z] <> '$' DO
     BEGIN
     IF BUF[Z] = '?' THEN
    HELP
     ELSE
    IF BUF[Z] = '!' THEN
        DEBUG_MODE := NOT DEBUG_MODE
    ELSE
        IF BUF[Z] <> '$' THEN
        BEGIN
        ANSWER := EXPR;
        WRITELN;
        WRITELN ('THE ANSWER IS :', ANSWER:9:6)
        END;
     GET_EXPR
     END;
WRITELN;
WRITELN ('PROGRAM ENDED');
WRITELN
END.